home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / clickUtils.tcl < prev    next >
Encoding:
Text File  |  1997-12-20  |  16.7 KB  |  567 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  # 
  4.  #  FILE: "clickUtils.tcl"
  5.  #                                    created: 11/2/96 {9:17:08 am} 
  6.  #                                last update: 20/12/97 {7:09:10 pm} 
  7.  #  History
  8.  # 
  9.  #         Expanded version of old 'DblClickAux.tcl'
  10.  # 
  11.  # Authors: Tom Pollard <pollard@chem.columbia.edu>
  12.  #          Tom Scavo   <trscavo@syr.edu>
  13.  #          Vince Darley <darley@fas.harvard.edu>
  14.  # 
  15.  #  modified by  rev reason
  16.  #  -------- --- --- -----------
  17.  #  9/97     VMD 1.0 reorganised for new alpha distribution.
  18.  # ###################################################################
  19.  ##
  20.  
  21. #############################################################################
  22. # Take any valid Macintosh filespec as input, and return the
  23. # corresponding absolute filespec.  Filenames without an explicit
  24. # folder are resolved relative to the folder of the current document.
  25. #
  26. proc absolutePath {filename}    {
  27.     set    name [file tail    $filename]
  28.     set    subdir [file dirname $filename]
  29.     if { [string length $subdir] > 0 && [string index $subdir 0] != ":" } {
  30.         set    dir    ""
  31.     } else {
  32.         set    dir    [file dirname [lindex [winNames    -f]    0]]
  33.     }
  34.     return    "$dir$subdir:$name"
  35. }
  36.  
  37. #############################################################################
  38. # Open the file specified by the full pathname "$filename"
  39. # If it's already open, just switch to it without any fuss.
  40. #
  41. proc openFileQuietly {filename}    {
  42.     if {[lsearch [winNames -f]    $filename] >= 0} {
  43.         bringToFront $filename
  44.     } elseif {[file exists $filename]} {
  45.         edit -w    $filename
  46.     } else {
  47.         error "Couldn''t find \"$filename\""
  48.     }
  49. }
  50.  
  51. #############################################################################
  52. # Searches $filename for the given pattern $searchString.  If the 
  53. # search is successful, returns the matched string; otherwise returns
  54. # the empty string.  If the flag 'indices' is true and the search is
  55. # successful, returns a list of two pos giving the indices of the
  56. # found string; otherwise returns the list '-1 -1'.
  57. #
  58. proc searchInFile {filename searchString {indices 0}} {
  59.     # Get the text of the file to be searched:
  60.     if {[lsearch [winNames -f]    $filename] >= 0} {
  61.         set fileText [getText -w $filename 0 [maxPos -w $filename]]
  62.     } elseif {[file exists $filename]} {
  63.         set fd [open $filename]
  64.         set fileText [read $fd]
  65.         close $fd
  66.     } else {
  67.         if { $indices } {
  68.             return [list -1 -1]
  69.         } else {
  70.             return ""
  71.         }
  72.     }
  73.     # Search the text for the search string:
  74.     if { $indices } {
  75.         if {[regexp -indices $searchString $fileText mtch]} {
  76.             # Fixes an apparent bug in 'regexp':
  77.             return [list [lindex $mtch 0] [expr [lindex $mtch 1] + 1]]
  78.         } else {        
  79.             return [list -1 -1]
  80.         }
  81.     } else {
  82.         if {[regexp $searchString $fileText mtch]} {
  83.             return $mtch
  84.         } else {        
  85.             return ""
  86.         }
  87.     }
  88. }
  89.  
  90. #############################################################################
  91. #  Read and return the complete contents of the specified file.
  92. #
  93. proc readFile {fileName} {
  94.     if {[file exists $fileName] && [file readable $fileName]} {
  95.        set fileid [open $fileName "r"]
  96.        set contents [read $fileid]
  97.        close $fileid
  98.        return $contents
  99.     } else {
  100.        error "No readable file found"
  101.     }
  102. }
  103.  
  104. #############################################################################
  105. #  Save $text in $filename.  If $text is null, create an empty file.
  106. #  Overwrite if $overwrite is true or the file does not exist; 
  107. #  otherwise, prompt the user.
  108. #
  109. proc writeFile {filename {text {}} {overwrite 0}} {
  110.     if { $overwrite || ![file exists $filename] } {
  111.         message "Saving $filename…"
  112.         set fd [open $filename "w"]
  113.         puts $fd $text
  114.         close $fd
  115.     } else {
  116.         if [dialog::yesno "File $filename exists!  Overwrite?"] {
  117.             writeFile $filename $text 1
  118.         } else {
  119.             message "No file written"
  120.         }
  121.     }
  122. }
  123.  
  124.  
  125. #############################################################################
  126. #  Highlight (select) a particular line in the designated file, opening the
  127. #  file if necessary.  Returns the full name of the buffer containing the
  128. #  opened file.  If provided, a message is displayed on the status line.
  129. #
  130. proc gotoFileLine {fname line {mesg {}}} {
  131.     if {[lsearch [winNames -f] "*$fname"] >= 0} {
  132.         bringToFront $fname
  133.     } elseif {[lsearch [winNames] "*$fname"] >= 0} {
  134.         bringToFront $fname
  135.     } elseif {[file exists $fname]} {
  136.         edit $fname
  137.         catch {shrinkWindow 2}
  138.     } else {
  139.         alertnote "File \" $fname \" not found."
  140.         return
  141.     }
  142.     set pos [rowColToPos $line 0]
  143.     select [lineStart $pos] [nextLineStart $pos]
  144.     if {[string length $mesg]} { message $mesg }
  145.     return [win::Current]
  146. }
  147.  
  148. ###########################################################################
  149. #  Parse a string into "word"s, which include blocks of non-space text,
  150. #  double- and single-quoted strings, and blocks of text enclosed in 
  151. #  balanced parentheses or curly brackets.
  152. #
  153. #  If a word is delimited by a quote or paren character (\", \', \(, or \{),
  154. #  then _that_ particular delimiter may be included within the word if it is 
  155. #  backslash-quoted, as above.  No other characters are special or need quoting
  156. #  with that word.  The quoted delimiters are unquoted in the list of words 
  157. #  returned.  
  158. #
  159. proc parseWords {entry} {
  160.     set slash "\\"
  161.     set qslash "\\\\"
  162.     
  163.     set words {}
  164.     set entry [string trim $entry]
  165.  
  166.     while {[string length $entry]} {
  167.         set delim [string range $entry 0 0]
  168.         set entry [string range $entry 1 end]
  169.  
  170. #        regexp $endPat   matches the end of the word
  171. #               $openPat  matches the open delimiter
  172. #               $unescPat matches escaped instances of the open/close delimiters
  173. #
  174. #        $type == "quote" means open/close delimiters are the same
  175. #              == "paren" means there's a close delimiter and nesting is possible
  176. #              == "unquoted" means the word is delimited by whitespace.
  177. #
  178.         if {$delim == {"}} {            set endPat {^([^"]*)"}
  179.                                         set unescPat {\\(")}
  180.                                         set type quote
  181.             
  182.         } elseif {$delim == {'}} {        set endPat {^([^']*)'}
  183.                                         set unescPat {\\(')}
  184.                                         set type quote
  185.             
  186.         } elseif {$delim == "\{"} {        set endPat "^(\[^\}\]*)\}"
  187.                                         set openPat "\{"
  188.                                         set unescPat "\\\\(\[\{\}\])"
  189.                                         set type paren
  190.             
  191.         } elseif {$delim == "("} {        set endPat {^([^)]*)\)}
  192.                                         set openPat {(}
  193.                                         set unescPat {\\([()])}
  194.                                         set type paren
  195.                                         
  196.         } else {                        set type unquoted
  197.         }
  198.         
  199.         if {$type == "quote"} {
  200.             set ck $qslash
  201.             set fld ""
  202.             while {$ck == $qslash} {
  203.                 set ok [regexp -indices $endPat $entry mtch sub1]
  204.                 if {$ok} {
  205.                     append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  206.                     set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  207.                     set pos [expr 1 + [lindex $mtch 1]]
  208.                     set entry [string range $entry $pos end]
  209.                 } else {
  210.                     error "Couldn't match $delim as field delimiter"
  211.                 }
  212.             }
  213.             set pos [expr [string length $fld] - 2]
  214.             set fld [string range $fld 0 $pos]
  215.             regsub -all $unescPat $fld {\1} fld
  216.            
  217.         } elseif {$type == "paren"} {
  218.         
  219.             set nopen 1
  220.             set nclose 0
  221.             set fld ""
  222.             while {$nopen - $nclose != 0} {
  223.                 set ok [regexp -indices $endPat $entry mtch sub1]
  224.                 if {$ok} {
  225.                     append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  226.                     set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  227.                     set entry [string range $entry [expr 1 + [lindex $mtch 1]] end]
  228.                     regsub -all $unescPat $fld {} fld1
  229.                     set nopen [llength [split $fld1 $openPat]]
  230.                     if {$ck != $qslash} { incr nclose }
  231.                 } else {
  232.                     error "Couldn't match $delim as field delimiter"
  233.                 } 
  234.             }
  235.             set pos [expr [string length $fld] - 2]
  236.             set fld [string range $fld 0 $pos]
  237.             regsub -all $unescPat $fld {\1} fld
  238.  
  239.         } elseif {$type == "unquoted"} {
  240.         
  241.             set entry ${delim}${entry}
  242.             set ok [regexp -indices {^([^     ]*)} $entry mtch sub1]
  243.             if {$ok} {
  244.                 set fld [string range $entry [lindex $sub1 0] [lindex $sub1 1]]
  245.                 set pos [expr 1 + [lindex $mtch 1]]
  246.                 set entry [string range $entry $pos end]
  247.             } else {
  248.                 set fld ""
  249.                 set entry ""
  250.             }
  251.         } else {
  252.             error "parseWords: unrecognized case"
  253.         }
  254.     
  255.         lappend words $fld
  256.         set entry [string trimleft $entry]
  257.     }
  258.     return $words
  259. }
  260.  
  261. ## 
  262.  # -------------------------------------------------------------------------
  263.  # 
  264.  #    "buildSubMenu" --
  265.  # 
  266.  #     Given a list of folders, 'buildSubMenu' returns a hierarchical    menu based 
  267.  #     on    the    files and subfolders in    each of    these folders.    Pathnames are 
  268.  #     optionally    stored in a    global array given by the argument 'filePaths'.     
  269.  #     The path's    index in this array    is formed by concatenating the submenu 
  270.  #     name and the filename,    allowing the pathname to be    retrieved by the 
  271.  #     procedure 'proc' when the menu    item is    selected.
  272.  # 
  273.  #     The search    may    be restricted to files with    specific extensions, or    files 
  274.  #     matching a    certain    pattern.  A    search depth may also be given,    with three 
  275.  #     levels    of subfolders assumed by default.
  276.  # 
  277.  #     See MacPerl.tcl or    latexMenu.tcl for examples.
  278.  # 
  279.  #     (originally written by    Tom    Pollard, with modifications    by Vince Darley    
  280.  #     and Tom Scavo)
  281.  # 
  282.  # --Version--Author------------------Changes-------------------------------
  283.  #      1.0      Tom Pollard                    original
  284.  #      2.0      <vince@das.harvard.edu> multiple extensions, optional    paths
  285.  #      2.1      Tom Scavo                        multiple folders
  286.  #      2.2      <vince@das.harvard.edu> pattern matching as well as exts
  287.  #      2.3      <vince@das.harvard.edu> handles unique menu-names and does text only
  288.  # -------------------------------------------------------------------------
  289.  ##
  290. proc buildSubMenu {folders name proc {filePaths ""} {exts ""} {depth 3} {fset ""}} {
  291.     global filesetmodeVars
  292.     if { $filePaths != "" } {
  293.         global $filePaths
  294.     }
  295.     
  296.     incr depth -1
  297.     set overallMenu {}
  298.     foreach folder $folders {
  299.         if {[file exists $folder]} {
  300.             if {![file isdirectory $folder]} {
  301.                 set folder "[file dirname $folder]:"
  302.             }
  303.             if {[string length [file tail $folder]] > 0} {
  304.                 set folder "$folder:"
  305.             }
  306.             if {$name == 0} {
  307.                 set name [file tail [file dirname $folder]]
  308.             }
  309.             # if it's a fileset, we register _before_ recursing
  310.             if { $fset != "" } {
  311.                 set mname [registerFilesetMenuName $fset $name $proc]
  312.             } else {
  313.                 set mname $name
  314.             }
  315.             set menu {}
  316.               if $filesetmodeVars(includeNonTextFiles) {
  317.                   set filenames [glob -nocomplain ${folder}*]
  318.               } else {
  319.                   set filenames [lsort -ignore [concat [glob -nocomplain ${folder}*:] \
  320.                   [glob -nocomplain -t TEXT ${folder}*]]] 
  321.             }
  322.             foreach m $filenames {
  323.                 if {[file isdirectory $m] && $depth > 0} {
  324.                     set subM [buildSubMenu [list ${m}] 0 $proc $filePaths $exts $depth $fset]
  325.                     if { $subM != "" } { lappend menu $subM }
  326.                 } elseif {[file isfile $m]} {
  327.                     set fname [file tail $m]
  328.                     if { $exts == "" || [lsearch ${exts} [file extension $fname] ] != -1 \
  329.                       || [string match $exts $fname] } {
  330.                         lappend menu $fname
  331.                         if { $filePaths != "" } {
  332.                             set ${filePaths}($name:$fname) $m
  333.                         }
  334.                     }
  335.                 }
  336.             }
  337.                 
  338.             if { $menu != "" } {
  339.                 set overallMenu [concat $overallMenu $menu]
  340.             }
  341.         } else {
  342.             beep
  343.             alertnote "buildSubMenu:  Folder $folder does not exist!"
  344.         }
  345.     }
  346.     
  347.     if { $overallMenu != "" } {
  348.         if { [string length $proc] > 1 } {
  349.             set pproc "-p $proc"
  350.         } else {
  351.             set pproc ""
  352.         }    
  353.         if { $fset != "" } {
  354.             if { [string length $proc] > 1 } { set pproc "-p subMenuProc" }
  355.         }     
  356.         return [concat {menu -m -n} [list $mname] $pproc [list $overallMenu]]
  357.         
  358.     } else {
  359.         return ""
  360.     }
  361. }
  362.  
  363. # in case we've done something odd elsewhere
  364. ensureset filesetmodeVars(includeNonTextFiles) 0
  365.  
  366. #############################################################################
  367. # Return a list of all subfolders found within $folder,
  368. # down to some maximum recursion depth.  The top-level
  369. # folder is not included in the returned list.
  370. #
  371. proc listSubfolders {folder {depth 3}} {
  372.     set folders {}
  373.     if {$depth > 0} {
  374.         incr depth -1
  375.         if {[string length [file tail $folder]] > 0} {
  376.             set folder "$folder:"
  377.         }
  378.         foreach m [glob -nocomplain  $folder\*] {
  379.             if {[file isdirectory $m]} {
  380.                 set folders [concat $folders [list $m]]
  381.                 set folders [concat $folders [listSubfolders ${m}: $depth]]
  382.             }
  383.         }
  384.     }
  385.     return $folders
  386. }
  387.  
  388. #############################################################################
  389.  
  390. proc commandClick {from to url} {
  391.     select $from
  392.     for {set i 0} {$i < 200} {incr i} {}
  393.     select $from $to
  394.     for {set i 0} {$i < 200} {incr i} {}
  395.     select $from
  396.     for {set i 0} {$i < 200} {incr i} {}
  397.     select $from $to
  398.     icURL $url
  399. }    
  400.  
  401. # Now doesn't add anything extra for windows which are not saved to disk.
  402. # To deal with shells and other similar windows. More general than only doing this for
  403. # shell mode.
  404. proc getIncludeFiles {} {
  405.     global minItemsInTitlePopup
  406.     if {([catch {mode::proc OptionTitlebar} lines] \
  407.       || [llength $lines] < $minItemsInTitlePopup) \
  408.       && [file exists [stripNameCount [win::Current]]]} {
  409.         pushd [file dirname [win::Current]]
  410.         if {[info exists lines] && $lines != ""} {
  411.             eval lappend lines "-" [glob *]
  412.         } else {
  413.             set lines [glob *]
  414.         }
  415.         popd
  416.     }
  417.     return $lines
  418. }
  419.  
  420. ## 
  421.  # -------------------------------------------------------------------------
  422.  #     
  423.  # "editIncludeFile" --
  424.  #    
  425.  #    Called when    you    select an item from    the    option-click pop-up.  Call a
  426.  #    mode-specific procedure    if possible, else assume it's a    file in    the    
  427.  #    same directory as the current window, and open it.  If the mode specific
  428.  #    procedure ends in an error, we use the default version.
  429.  # -------------------------------------------------------------------------
  430.  ##
  431. proc editIncludeFile {item} {
  432.     if [catch {mode::proc OptionTitlebarSelect $item}] {
  433.         if {[file isdirectory "[file dirname [win::Current]]:$item"]} {
  434.             file::showInFinder "[file dirname [win::Current]]:$item"
  435.         } else {
  436.             file::tryToOpen [list $item]
  437.         }
  438.     }
  439. }
  440.  
  441.  
  442. namespace eval file {}
  443.  
  444. proc file::showInFinder {{f ""}} {
  445.     if {$f == ""} {set f [win::Current]}
  446.     openFolder [file dirname $f]
  447.     switchTo Finder
  448. }
  449.  
  450. proc file::tryToOpen {{fname ""}} {
  451.     if {$fname == ""} {set fname [getSelect]}
  452.     set f "[file dirname [win::Current]]:${fname}"
  453.     if [file exists $f] {
  454.         openFileQuietly $f
  455.     } else {
  456.         alertnote "Sorry, I couldn't find that file.  You could install\
  457.           Vince's Additions which includes better include-path handling."
  458.     }
  459. }
  460.  
  461.  
  462. # Called from Alpha when titlebar "title" menu selected (command-mouse).
  463. proc getTitleBarPath {} {
  464.     global fetched
  465.     
  466.     set f [win::Current]
  467.     if {[info exists fetched($f)]} {
  468.         set nm "[car $fetched($f)]/[cadr $fetched($f)]/[file tail $f]"
  469.         regsub -all {//} $nm {/} nm
  470.         regsub -all {/} $nm {:} nm
  471.         return $nm
  472.     } else {
  473.         return $f
  474.     }
  475. }
  476.  
  477. proc titlebar {name} {
  478.     global fetched
  479.     
  480.     if {[info exists fetched([win::Current])]} {
  481.         set specs $fetched([win::Current])
  482.         regexp {[^:]*:(.*)} $name dummy dir
  483.         if {[regexp {:} $dir]} {
  484.             regexp {(.*):([^:]*)} $dir dummy dir fname
  485.         } else {
  486.             set fname ""
  487.         }
  488.         regsub -all {:} $dir {/} dir
  489.         ftpBrowse [car $specs] $dir [caddr $specs]  [cadddr $specs] $fname
  490.     } else {
  491.         if [key::shiftPressed] {
  492.             openFolder $name
  493.             switchTo Finder
  494.         } else {
  495.             findFile $name
  496.         }
  497.     }
  498. }
  499.  
  500. #===============================================================================
  501.  
  502. proc cmdDoubleClick {{from -1} {to -1} {shift 0} {option 0} {control 0}} {
  503.     global mode
  504.     
  505.     if {[expandURL] != ""} {
  506.         sendUrl [getSelect]
  507.     } else {
  508.         if {$from < 0} {
  509.             set from [getPos]
  510.             set to [selEnd]
  511.             if {$from == $to} {
  512.                 hiliteWord
  513.                 set from [getPos]
  514.                 set to [selEnd]
  515.             }
  516.         }
  517.         if {[set proc [mode::getProc DblClick]] != ""} {
  518.             if {[llength [info args $proc]] == 2} {
  519.                 $proc $from $to
  520.             } else {
  521.                 $proc $from $to $shift $option $control
  522.             }
  523.         } else {
  524.             message "No docs"
  525.         }
  526.     }    
  527. }
  528.  
  529. # (WTP 7/30/95) Slightly improved 'sendUrl'.
  530. # By accepting a text arg, this can now be used to make sendUrl 
  531. # hypertext links (useful for "mailto" links in documentation, f'rinstance) 
  532. #===============================================================================
  533. set htmlEventSuiteIDs(MOSS) {WWW!}
  534. set htmlEventSuiteIDs(MSIE) {WWW!}
  535.  
  536. proc sendUrl {{text {}}} {
  537.     if {$text == {}} { catch {set text [getSelect]} }
  538.     if {$text == {}} { set text [prompt {URL?} {}] }
  539.     if {[string length $text] == 0} { return }
  540.     
  541.     global htmlEventSuiteIDs browserSig browserSigs
  542.     
  543.     set name [file tail [app::launchAnyOfThese $browserSigs browserSig \
  544.       "Please locate your web browser:"]]
  545.     
  546.     if {![info exists htmlEventSuiteIDs($browserSig)]} {
  547.         alertnote "Can't send URLs to this HTML browser"
  548.         return
  549.     }
  550.     set suite $htmlEventSuiteIDs($browserSig)
  551.     
  552.     AEBuild "'${browserSig}'" $suite {OURL} {----} "“$text”"
  553.     switchTo $name
  554. }
  555.  
  556.  
  557. proc expandURL {} {
  558.     set pos [getPos]
  559.     set beg [lineStart $pos]
  560.     if {[string length [set whe [search -s -n -f 1 -r 1 -i 1 -m 0 -l [nextLineStart $pos] {[a-zA-Z0-9]+://[a-zA-Z/._0-9~-]+} $beg]]]} {
  561.         if {($pos >= [lindex $whe 0]) && ($pos < [lindex $whe 1])} {
  562.             eval select $whe
  563.             return $whe
  564.         }
  565.     }
  566. }
  567.